home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / boot / listing.pl < prev    next >
Encoding:
Text File  |  1997-07-02  |  6.1 KB  |  236 lines
  1. /*  $Id: listing.pl,v 1.5 1997/07/02 15:20:45 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: listing/1
  7. */
  8.  
  9. :- module($listing,
  10.     [ listing/0
  11.     , listing/1
  12.     , portray_clause/1
  13.     ]).
  14.  
  15. :- module_transparent
  16.     listing/0, 
  17.     listing/1, 
  18.     $listing/2, 
  19.     $listing2/3, 
  20.     $list_clauses/1.
  21.  
  22.  
  23. %   calls listing(Pred) for each current_predicate Pred.
  24.  
  25. listing :-
  26.     current_predicate(_, Pred), 
  27.     \+ predicate_property(Pred, built_in), 
  28.     nl, 
  29.     functor(Pred, Name, Arity),
  30.     $listing2(Name, Pred, Arity),
  31.     fail.
  32. listing.
  33.  
  34.  
  35. %   listing(PredSpecs)
  36.  
  37. listing(V) :-
  38.     var(V), !.       % ignore variables
  39. listing([]) :- !.
  40. listing([X|Rest]) :- !, 
  41.         listing(X), 
  42.         listing(Rest).
  43. listing(X) :-
  44.     $find_predicate(X, Preds), 
  45.     $listing(Preds, X).
  46.  
  47. $listing(Preds, _) :-
  48.     member(Pred, Preds),
  49.     nl, 
  50.     $define_predicate(Pred),
  51.     $strip_module(Pred, _, Head), 
  52.     functor(Head, Name, Arity), 
  53.         $listing2(Name, Pred, Arity), 
  54.         fail.
  55. $listing(_, _).
  56.  
  57. $listing2(Name, Pred, Arity) :-
  58.     predicate_property(Pred, undefined), !, 
  59.     format('%   Undefined: ~w/~w~n', [Name, Arity]).
  60. $listing2(Name, Pred, Arity) :-
  61.     predicate_property(Pred, foreign), !, 
  62.     format('%   Foreign: ~w/~w~n', [Name, Arity]).
  63. $listing2(Name, Pred, Arity) :-
  64.     $strip_module(Pred, Module, Head),
  65.     notify_changed(Module, Head),
  66.     $list_declarations(Name, Pred, Arity, []), 
  67.     $list_clauses(Pred).
  68.  
  69. $list_declarations(Name, Pred, Arity, Sofar) :-
  70.     \+ member((dynamic Name/Arity), Sofar), 
  71.     predicate_property(Pred, (dynamic)), !, 
  72.     $list_declarations(Name, Pred, Arity, [(dynamic Name/Arity)|Sofar]).
  73. $list_declarations(Name, Pred, Arity, Sofar) :-
  74.     \+ member((multifile Name/Arity), Sofar), 
  75.     predicate_property(Pred, (multifile)), !, 
  76.     $list_declarations(Name, Pred, Arity, [(multifile Name/Arity)|Sofar]).
  77. $list_declarations(Name, Pred, Arity, Sofar) :-
  78.     \+ member((module_transparent Name/Arity), Sofar), 
  79.     predicate_property(Pred, (transparent)), !, 
  80.     $list_declarations(Name, Pred, Arity, [(module_transparent Name/Arity)|Sofar]).
  81. $list_declarations(_, _, _, []) :- !.
  82. $list_declarations(_, _, _, List) :-
  83.     $write_declarations(List), nl.
  84.  
  85. $write_declarations([]) :- !.
  86. $write_declarations([H|T]) :-
  87.     format(':- ~q.~n', [H]),
  88.     $write_declarations(T).
  89.  
  90. $list_clauses(Pred) :-
  91.     context_module(Source), 
  92.     $strip_module(Pred, Module, Head), 
  93.     clause(Pred, Body), 
  94.         $list_module(Module, Source), 
  95.         portray_clause((Head:-Body)), 
  96.     fail.
  97.  
  98. $list_module(system, _) :- !.
  99. $list_module(Module, Module) :- !.
  100. $list_module(Module, _) :-
  101.     format('~q:', [Module]).
  102.  
  103. notify_changed(user, Head) :-
  104.     current_predicate(_, system:Head),
  105.     \+ ( predicate_property(user:Head, imported_from(System)),
  106.          (System == system ; $default_module(System, system, system))
  107.        ),
  108.     \+ predicate_property(system:Head, (dynamic)), !,
  109.     functor(Head, Name, Arity),
  110.     format('%   NOTE: system definition has been overruled for ~w/~w~n~n',
  111.                 [Name, Arity]).
  112. notify_changed(_, _).
  113.  
  114. %    portray_clause(+Clause)
  115. %    Portray `Clause' on the current output stream.   Layout  of  the
  116. %    clause  is  to our best standards.  As the actual variable names
  117. %    are not available we use A, B, ... Deals with ';', '|',  '->'  and
  118. %    various calls via meta-call predicates.
  119.  
  120. portray_clause(Term) :-
  121.     numbervars(Term, $VAR, 0, _), 
  122.     $portray_clause(Term), 
  123.     fail.                    % undo bindings        
  124. portray_clause(_).
  125.  
  126. $portray_clause((Head :- true)) :- !, 
  127.     $portray_head(Head), 
  128.     put(0'.), nl.
  129. $portray_clause((Head :- Body)) :- !, 
  130.     $portray_head(Head), 
  131.     write(' :-'), 
  132.     $portray_body(Body, 2, indent), 
  133.     put(0'.), nl.
  134. $portray_clause(Fact) :-
  135.     $portray_clause((Fact :- true)).
  136.  
  137. $portray_head(Head) :-
  138.     pprint(Head).
  139.  
  140. $portray_body(!, _, _) :- !, 
  141.     write(' !').
  142. $portray_body((!, Clause), Indent, _) :- !, 
  143.     write(' !,'), 
  144.     $portray_body(Clause, Indent, indent).
  145. $portray_body(Term, Indent, indent) :- !, 
  146.     nl, $portray_indent(Indent), 
  147.     $portray_body(Term, Indent, noindent).
  148. $portray_body((A, B), Indent, _) :- !, 
  149.     $portray_body(A, Indent, noindent), 
  150.     write(','), 
  151.     $portray_body(B, Indent, indent).
  152. $portray_body(Or, Indent, _) :-
  153.     memberchk(Or, [(_;_), (_|_), (_->_), (_*->_)]), !, 
  154.     write('(   '), 
  155.     $portray_or(Or, Indent), 
  156.     nl, $portray_indent(Indent), 
  157.     write(')').
  158. $portray_body(Meta, Indent, _) :-
  159.     $meta_call(Meta, N), !, 
  160.     $portray_meta(Meta, N, Indent).
  161. $portray_body(Clause, _, _) :-
  162.     pprint(Clause).
  163.  
  164. $portray_or((If -> Then ; Else), Indent) :- !, 
  165.     succ(Indent, NestIndent), 
  166.     $portray_body(If, NestIndent, noindent),     
  167.     nl, $portray_indent(Indent),
  168.     write('->  '), 
  169.     $portray_body(Then, NestIndent, noindent), 
  170.     nl, $portray_indent(Indent), 
  171.     write(';   '), 
  172.     $portray_or(Else, Indent).
  173. $portray_or((If *-> Then ; Else), Indent) :- !, 
  174.     succ(Indent, NestIndent), 
  175.     $portray_body(If, NestIndent, noindent),     
  176.     nl, $portray_indent(Indent),
  177.     write('*-> '), 
  178.     $portray_body(Then, NestIndent, noindent), 
  179.     nl, $portray_indent(Indent), 
  180.     write(';   '), 
  181.     $portray_or(Else, Indent).
  182. $portray_or((If -> Then), Indent) :- !, 
  183.     succ(Indent, NestIndent), 
  184.     $portray_body(If, NestIndent, noindent),     
  185.     nl, $portray_indent(Indent), 
  186.     write('->  '), 
  187.     $portray_or(Then, Indent).
  188. $portray_or((A;B), Indent) :- !, 
  189.     succ(Indent, OrIndent), 
  190.     $portray_body(A, OrIndent, noindent), 
  191.     nl, $portray_indent(Indent), 
  192.     write(';   '), 
  193.     $portray_or(B, Indent).
  194. $portray_or((A|B), Indent) :- !, 
  195.     succ(Indent, OrIndent), 
  196.     $portray_body(A, OrIndent, noindent),     
  197.     nl, $portray_indent(Indent), 
  198.     write('|   '), 
  199.     $portray_or(B, Indent).
  200. $portray_or(A, Indent) :-
  201.     succ(Indent, OrIndent), 
  202.     $portray_body(A, OrIndent, noindent).
  203.  
  204. $meta_call(call(_), 1).
  205. $meta_call(once(_), 1).
  206. $meta_call(not(_), 1).
  207. $meta_call(\+(_), 1).
  208. $meta_call(ignore(_), 1).
  209.  
  210. $portray_meta(Term, N, Indent) :-
  211.     arg(N, Term, Arg), 
  212.     memberchk(Arg, [(_, _), (_;_), (_|_), (_->_)]), !, 
  213.     functor(Term, Name, _), 
  214.     write(Name), write('(('), 
  215.     succ(Indent, CallIndent), 
  216.     $portray_body(Arg, CallIndent, indent), 
  217.     nl, $portray_indent(CallIndent), 
  218.     write('))').    
  219. $portray_meta(Term, _, _) :-
  220.     pprint(Term).    
  221.  
  222. $portray_indent(N) :-
  223.     Tab is N // 2, 
  224.     Space is (N mod 2) * 4, 
  225.     $n_times(Tab, put(9)), 
  226.     tab(Space).
  227.  
  228. $n_times(N, Goal) :-
  229.     between(1, N, _), 
  230.     Goal, 
  231.     fail.
  232. $n_times(_, _).    
  233.  
  234. pprint(Term) :-
  235.     writeq(Term).
  236.